home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / network.scm < prev    next >
Text File  |  1995-10-31  |  33KB  |  987 lines
  1. ;;; Networking for the Scheme Shell
  2. ;;; Copyright (c) 1994-1995 by Brian D. Carlstrom.
  3. ;;; Copyright (c) 1994 by Olin Shivers.
  4.  
  5. ;;; Scheme48 implementation.
  6.  
  7. (foreign-source
  8.  "#include <sys/types.h>"
  9.  "#include <sys/socket.h>"
  10.  ""
  11.  "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  12.  "#include \"network1.h\""
  13.  ""
  14.  "extern int errno;"
  15.  "extern int h_errno;"
  16.  ""
  17.  "#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno))"
  18.  "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  19.  "#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)"
  20.  "" )
  21.  
  22. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  23. ;;; High Level Prototypes
  24. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  25.  
  26. (define (socket-connect protocol-family socket-type . args)
  27.   (let* ((sock (create-socket protocol-family
  28.                   socket-type))
  29.      (addr (cond ((= protocol-family
  30.              protocol-family/internet)
  31.               (let* ((host (car  args))
  32.                  (port (cadr args))
  33.                  (host (car (host-info:addresses 
  34.                      (name->host-info host))))
  35.                  (port (cond ((integer? port) port)
  36.                      ((string? port)
  37.                       (service-info:port 
  38.                        (service-info (cadr args) "tcp")))
  39.                      (else
  40.                       (error
  41.                        "socket-connect: bad arg ~s"
  42.                        args)))))
  43.             (internet-address->socket-address host port)))
  44.              ((= protocol-family
  45.              protocol-family/unix)
  46.               (unix-address->socket-address (car args)))
  47.              (else 
  48.               (error "socket-connect: unsupported protocol-family ~s"
  49.                  protocol-family)))))
  50.     (connect-socket sock addr)
  51.     sock))
  52.  
  53. (define (bind-listen-accept-loop protocol-family proc arg)
  54.   (let* ((sock (create-socket protocol-family socket-type/stream))
  55.      (addr (cond ((= protocol-family
  56.              protocol-family/internet)
  57.               (let ((port (cond ((integer? arg) arg)
  58.                     ((string? arg)
  59.                      (service-info:port 
  60.                       (service-info arg "tcp")))
  61.                     (else
  62.                      (error "socket-connect: bad arg ~s"
  63.                         arg)))))
  64.             (internet-address->socket-address internet-address/any
  65.                               arg)))
  66.              ((= protocol-family
  67.              protocol-family/unix)
  68.               (unix-address->socket-address arg))
  69.              (else 
  70.       (error "bind-listen-accept-loop: unsupported protocol-family ~s"
  71.          protocol-family)))))
  72.     (set-socket-option sock level/socket socket/reuse-address #t)
  73.     (bind-socket sock addr)
  74.     (listen-socket sock 5)
  75.     (let loop ()
  76.       (call-with-values 
  77.        (lambda () (accept-connection sock))
  78.        proc)
  79.       (loop))))
  80.  
  81. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  82. ;;; Socket Record Structure
  83. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  84. (define-record socket
  85.   family                ; protocol family
  86.   inport                ; input port 
  87.   outport)                ; output port
  88.  
  89. (define-record socket-address
  90.   family                ; address family
  91.   address)                ; address
  92.  
  93. ;;; returns the fdes of a socket
  94. ;;; not exported
  95. (define (socket->fdes sock)
  96.   (fdport-data:fd (extensible-input-port-local-data (socket:inport sock))))
  97.  
  98. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  99. ;;; Socket Address Routines
  100. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  101. (define (internet-address->socket-address address32 port16)
  102.   (cond ((not (<= 0 address32 #xffffffff))
  103.      (error "internet-address->socket-address: address out of range ~s"
  104.         address32))
  105.     ((not (<= 0 port16 #xffff))
  106.      (error "internet-address->socket-address: port out of range ~s"
  107.         port16))
  108.     (else 
  109.      (make-socket-address address-family/internet
  110.                   (string-append (integer->string address32) 
  111.                          (integer->string port16))))))
  112.   
  113. (define (socket-address->internet-address sockaddr)
  114.   (if (or (not (socket-address? sockaddr))
  115.       (not (= (socket-address:family sockaddr) 
  116.           address-family/internet)))
  117.       (error "socket-address->internet-address: internet socket expected ~s"
  118.          sockaddr)
  119.       (values (string->integer (substring (socket-address:address sockaddr) 
  120.                       0 4))
  121.           (string->integer (substring (socket-address:address sockaddr)
  122.                       4 8)))))
  123.  
  124. (define (unix-address->socket-address path)
  125.   (if (> (string-length path) 108)
  126.       (error "unix-address->socket-address: path too long ~s" path)
  127.       (make-socket-address address-family/unix path)))
  128.  
  129. (define (socket-address->unix-address sockaddr)
  130.   (if (or (not (socket-address? sockaddr))
  131.       (not (= (socket-address:family sockaddr) 
  132.           address-family/unix)))
  133.       (error "socket-address->unix-address expects an unix socket ~s" sockaddr)
  134.       socket-address:address))
  135.  
  136. (define (make-addr af)
  137.   (make-string (cond ((= af address-family/unix) 108)
  138.              ((= af address-family/internet) 8)
  139.              (else 
  140.               (error "make-addr: unknown address-family ~s" af)))))
  141.  
  142. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  143. ;;; socket syscall
  144. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  145. (define (create-socket pf type . maybe-protocol)
  146.   (receive (protocol)
  147.        (parse-optionals maybe-protocol 0)
  148.     (if (not (and (integer? pf)
  149.           (integer? type)
  150.           (integer? protocol)))
  151.     (error "create-socket: integer arguments expected ~s ~s ~s" 
  152.            pf type protocol)
  153.     (let* ((fd  (%socket pf type protocol))
  154.            (in  (make-input-fdport fd))
  155.            (out (dup->outport in)))
  156.       (%install-port fd in)
  157.       (make-socket pf in out)))))
  158.  
  159. (define-foreign %socket/errno
  160.   (socket (integer pf)
  161.       (integer type)
  162.       (integer protocol))
  163.   (multi-rep (to-scheme integer errno_or_false)
  164.              integer))
  165.  
  166. (define-errno-syscall (%socket pf type protocol) %socket/errno
  167.   sockfd)
  168.  
  169. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  170. ;;; close syscall
  171. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  172. (define (close-socket sock)
  173.   (close (socket:inport  sock))
  174.   (close (socket:outport sock)))
  175.  
  176. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  177. ;;; bind syscall
  178. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  179. (define (bind-socket sock name)
  180.   (cond ((not (socket? sock))
  181.      (error "bind-socket: socket expected ~s" sock))
  182.     ((not (socket-address? name))
  183.      (error "bind-socket: socket-address expected ~s" name))
  184.     (else
  185.      (let ((family (socket:family sock)))
  186.        (if (not (= family (socket-address:family name)))
  187.            (error 
  188.         "bind-socket: trying to bind incompatible address to socket ~s"
  189.         name)
  190.            (%bind (socket->fdes sock)
  191.               family
  192.               (socket-address:address name)))))))
  193.  
  194. (define-foreign %bind/errno
  195.   (scheme_bind (integer     sockfd)    ; socket fdes
  196.            (integer     family)    ; address family
  197.            (string-desc name))    ; scheme descriptor
  198.   (to-scheme integer errno_or_false))
  199.  
  200. (define-simple-errno-syscall (%bind sockfd family name) %bind/errno)
  201.  
  202. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  203. ;;; connect syscall
  204. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  205. (define (connect-socket sock name)
  206.   (cond ((not (socket? sock))
  207.      (error "connect-socket: socket expected ~s" sock))
  208.     ((not (socket-address? name))
  209.      (error "connect-socket: socket-address expected ~s" name))
  210.     (else
  211.      (let ((family (socket:family sock)))
  212.        (cond ((not (= family (socket-address:family name)))
  213.           (error 
  214.        "connect: trying to connect socket to incompatible address ~s"
  215.        name))
  216.          (else
  217.           (%connect (socket->fdes sock)
  218.                 (socket:family sock)
  219.                 (socket-address:address name))))))))
  220.  
  221. (define-foreign %connect/errno
  222.   (scheme_connect (integer sockfd)    ; socket fdes
  223.           (integer family)    ; address family
  224.           (desc    name))    ; scheme descriptor
  225.   (to-scheme integer errno_or_false))
  226.  
  227. (define-simple-errno-syscall (%connect sockfd family name) %connect/errno)
  228.  
  229. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  230. ;;; listen syscall
  231. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  232. (define (listen-socket sock backlog)
  233.   (cond ((not (socket? sock))
  234.      (error "listen-socket: socket expected ~s" sock))
  235.     ((not (integer? backlog))
  236.      (error "listen-socket: integer expected ~s" backlog))
  237.     (else
  238.      (%listen (socket->fdes sock) backlog))))
  239.      
  240. (define-foreign %listen/errno
  241.   (listen (integer sockfd)    ; socket fdes
  242.       (integer backlog))    ; backlog
  243.   (to-scheme integer errno_or_false))
  244.  
  245. (define-simple-errno-syscall (%listen sockfd backlog) %listen/errno)
  246.  
  247. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  248. ;;; accept syscall
  249. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  250. (define (accept-connection sock)
  251.   (if (not (socket? sock))
  252.       (error "accept-connection: socket expected ~s" sock)
  253.       (let* ((family (socket:family sock))
  254.          (name   (make-addr family))
  255.          (fd     (%accept (socket->fdes sock) family name))
  256.          (in     (make-input-fdport fd))
  257.          (out    (dup->outport in)))
  258.     (%install-port fd in)
  259.     (values (make-socket family in out)
  260.         (make-socket-address family name)))))
  261.  
  262. (define-foreign %accept/errno
  263.   (scheme_accept (integer     sockfd)
  264.          (integer     family)
  265.          (string-desc name))
  266.   (multi-rep (to-scheme integer errno_or_false)
  267.              integer))
  268.  
  269. (define-errno-syscall (%accept sock family name) %accept/errno
  270.   sockfd)
  271.  
  272. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  273. ;;; getpeername syscall
  274. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  275. (define (socket-remote-address sock)
  276.   (if (or (not (socket? sock))
  277.       (not (= (socket:family sock) address-family/internet)))
  278.       (error "socket-remote-address: internet socket expected ~s" sock)
  279.       (let* ((family (socket:family sock))
  280.          (name   (make-addr family)))
  281.     (%peer-name (socket->fdes sock)
  282.             family
  283.             name)
  284.     (make-socket-address family name))))
  285.  
  286. (define-foreign %peer-name/errno
  287.   (scheme_peer_name (integer     sockfd)
  288.             (integer     family)
  289.             (string-desc name))
  290.   (to-scheme integer errno_or_false))
  291.  
  292. (define-simple-errno-syscall (%peer-name sock family name) %peer-name/errno)
  293.  
  294. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  295. ;;; getsockname syscall
  296. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  297. (define (socket-local-address sock)
  298.   (if (or (not (socket? sock))
  299.       (not (= (socket:family sock) address-family/internet)))
  300.       (error "socket-local-address: internet socket expected ~s" sock)
  301.       (let* ((family (socket:family sock))
  302.          (name   (make-addr family)))
  303.     (%socket-name (socket->fdes sock)
  304.               family
  305.               name)
  306.     (make-socket-address family name))))
  307.  
  308. (define-foreign %socket-name/errno
  309.   (scheme_socket_name (integer     sockfd)
  310.               (integer     family)
  311.               (string-desc name))
  312.   (to-scheme integer "False_on_zero"))
  313.  
  314. (define-simple-errno-syscall 
  315.   (%socket-name sock family name) %socket-name/errno)
  316.  
  317. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  318. ;;; shutdown syscall
  319. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  320. (define (shutdown-socket sock how)
  321.   (cond ((not (socket? sock))
  322.      (error "shutdown-socket: socket expected ~s" sock))
  323.     ((not (integer? how))
  324.      (error "shutdown-socket: integer expected ~s" how))
  325.     (else
  326.      (%shutdown (socket->fdes sock) how))))
  327.  
  328. (define-foreign %shutdown/errno
  329.   (shutdown (integer sockfd)
  330.         (integer how))
  331.   (to-scheme integer errno_or_false))
  332.  
  333. (define-simple-errno-syscall 
  334.   (%shutdown sock how) %shutdown/errno)
  335.  
  336. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  337. ;;; socketpair syscall
  338. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  339. (define (create-socket-pair type)
  340.   (if (not (integer? type))
  341.       (error "create-socket-pair: integer argument expected ~s" type)
  342.       (receive (s1 s2)
  343.            (%socket-pair type)
  344.         (let* ((in1  (make-input-fdport s1))
  345.            (out1 (dup->outport in1))
  346.            (in2  (make-input-fdport s2))
  347.            (out2 (dup->outport in2)))
  348.       (%install-port s1 in1)
  349.       (%install-port s2 in2)
  350.       (values (make-socket protocol-family/unix in1 out1)
  351.           (make-socket protocol-family/unix in2 out2))))))
  352.  
  353. ;; based on pipe in syscalls.scm
  354. (define-foreign %socket-pair/errno
  355.   (scheme_socket_pair (integer type))
  356.   (to-scheme integer errno_or_false)
  357.   integer
  358.   integer)
  359.  
  360. (define-errno-syscall 
  361.   (%socket-pair type) %socket-pair/errno
  362.   sockfd1
  363.   sockfd2)
  364.  
  365. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  366. ;;; recv syscall
  367. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  368. (define (receive-message socket len . maybe-flags) 
  369.   (receive (flags)
  370.        (parse-optionals maybe-flags 0)
  371.     (cond ((not (socket? socket))
  372.        (error "receive-message: socket expected ~s" socket))
  373.       ((or (not (integer? flags))
  374.            (not (integer? len)))
  375.        (error "receive-message: integer expected ~s ~s" flags len))
  376.       (else 
  377.        (let ((s (make-string len)))
  378.          (receive (nread from)
  379.               (receive-message! socket s 0 len flags)
  380.                (values
  381.         (cond ((not nread) #f)    ; EOF
  382.               ((= nread len) s)
  383.               (else (substring s 0 nread)))
  384.         from)))))))
  385.  
  386. (define (receive-message! socket s . maybe-args)
  387.   (if (not (string? s))
  388.       (error "receive-message!: string expected ~s" s)
  389.       (receive (start end flags)
  390.            (parse-optionals maybe-args 0 (string-length s) 0)
  391.            (cond ((not (socket? socket))
  392.               (error "receive-message!: socket expected ~s" socket))
  393.              ((not (or (integer? flags)
  394.                    (integer? start)
  395.                    (integer? end)))
  396.               (error "receive-message!: integer expected ~s ~s ~s"
  397.                  flags start end))
  398.              (else 
  399.               (generic-receive-message! (socket->fdes socket) flags
  400.                         s start end 
  401.                         recv-substring!/errno
  402.                         (socket:family socket)))))))
  403.  
  404. (define (generic-receive-message! sockfd flags s start end reader from)
  405.   (if (bogus-substring-spec? s start end)
  406.       (error "Bad substring indices" 
  407.          reader sockfd flags
  408.          s start end from))
  409.   (let ((addr (make-addr from)))
  410.     (let loop ((i start))
  411.       (if (>= i end) (- i start)
  412.       (receive (err nread) 
  413.            (reader sockfd flags s i end addr)
  414.          (cond (err (if (= err errno/intr) (loop i)
  415.                  ;; Give info on partially-read data in error packet.
  416.                 (errno-error err reader sockfd flags
  417.                      s start i end addr)))
  418.  
  419.            ((zero? nread)    ; EOF
  420.             (values
  421.              (let ((result (- i start)))
  422.                (and (not (zero? result)) result))
  423.              from))
  424.            (else (loop (+ i nread)))))))))
  425.  
  426. (define (receive-message/partial socket len . maybe-flags)
  427.   (receive (flags)
  428.        (parse-optionals maybe-flags 0)
  429.     (cond ((not (socket? socket))
  430.        (error "receive-message/partial: socket expected ~s" socket))
  431.       ((or (not (integer? flags))
  432.            (not (integer? len)))
  433.        (error "receive-message/partial: integer expected ~s ~s" flags len))
  434.       (else 
  435.        (let ((s (make-string len)))
  436.          (receive (nread addr)
  437.               (receive-message!/partial socket s 0 len flags)
  438.               (values 
  439.                (cond ((not nread) #f)    ; EOF
  440.                  ((= nread len) s)
  441.                  (else (substring s 0 nread)))
  442.                addr)))))))
  443.  
  444. (define (receive-message!/partial socket s . maybe-args)
  445.   (if (not (string? s))
  446.       (error "receive-message!/partial: string expected ~s" s)
  447.       (receive (start end flags)
  448.            (parse-optionals maybe-args 0 (string-length s) 0)
  449.            (cond ((not (socket? socket))
  450.               (error "receive-message!/partial: socket expected ~s"
  451.                  socket))
  452.              ((not (integer? flags))
  453.               (error "receive-message!/partial: integer expected ~s"
  454.                  flags))
  455.              (else 
  456.               (generic-receive-message!/partial (socket->fdes socket)
  457.                             flags 
  458.                             s start end
  459.                             recv-substring!/errno
  460.                             (socket:family socket)))))))
  461.  
  462. (define (generic-receive-message!/partial sockfd flags s start end reader from)
  463.   (if (bogus-substring-spec? s start end)
  464.       (error "Bad substring indices" reader s start end))
  465.  
  466.   (if (= start end) 0 ; Vacuous request.
  467.       (let ((addr (make-addr from)))
  468.     (let loop ()
  469.       (receive (err nread) 
  470.            (reader sockfd flags s start end addr)
  471.          (if err
  472.          (case err
  473.            ((errno/intr) (loop))
  474.            ; No forward-progess here.
  475.            ((errno/wouldblock errno/again) 0) 
  476.            (else (errno-error err reader sockfd flags
  477.                       s start start end addr)))
  478.          (values
  479.           (and (not (zero? nread)) nread)
  480.           (make-socket-address from addr))))))))
  481.  
  482. (define-foreign recv-substring!/errno
  483.   (recv_substring (integer sockfd)
  484.           (integer flags)
  485.           (string-desc buf)
  486.           (integer start)
  487.           (integer end)
  488.           (string-desc name))
  489.   (multi-rep (to-scheme integer errno_or_false)
  490.          integer))
  491.  
  492. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  493. ;;; send syscall
  494. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  495.  
  496. (define (send-message socket s . maybe-args)
  497.   (receive (start end flags addr)
  498.        (parse-optionals maybe-args
  499.                 0 (string-length s) 0 #f)
  500.     (cond ((not (socket? socket))
  501.        (error "send-message: socket expected ~s" socket))
  502.       ((not (integer? flags))
  503.        (error "send-message: integer expected ~s" flags))
  504.       ((not (string? s))
  505.        (error "send-message: string expected ~s" s))
  506.       (else 
  507.        (generic-send-message (socket->fdes socket) flags
  508.                  s start end
  509.                  send-substring/errno 
  510.                  (if addr (socket-address:family addr) 0)
  511.                  (and addr (socket-address:address addr)))))))
  512.  
  513. (define (generic-send-message sockfd flags s start end writer family addr)
  514.   (if (bogus-substring-spec? s start end)
  515.       (error "Bad substring indices" 
  516.          sockfd flags family addr
  517.          s start end writer))
  518.   (let ((addr (if addr (make-addr family) "")))
  519.     (let loop ((i start))
  520.       (if (< i end)
  521.       (receive (err nwritten) 
  522.            (writer sockfd flags s i end family addr)
  523.          (if err
  524.          (case err
  525.            ((errno/intr) (loop i))
  526.            (else (errno-error err sockfd flags family addr
  527.                       s start i end writer)))
  528.          (loop (+ i nwritten))))))))
  529.  
  530. (define (send-message/partial socket s . maybe-args)
  531.   (receive (start end flags addr)
  532.        (parse-optionals maybe-args
  533.                 0 (string-length s) 0 #f)
  534.     (cond ((not (socket? socket))
  535.        (error "send-message/partial: socket expected ~s" socket))
  536.       ((not (integer? flags))
  537.        (error "send-message/partial: integer expected ~s" flags))
  538.       ((not (string? s))
  539.        (error "send-message/partial: string expected ~s" s))
  540.       (else 
  541.            (generic-send-message/partial (socket->fdes socket) flags
  542.                      s start end
  543.                      send-substring/errno
  544.                      (if addr (socket-address:family addr) 0)
  545.                      (if addr (socket-address:address addr)))))))
  546.  
  547. (define (generic-send-message/partial sockfd flags s start end writer family addr)
  548.   (if (bogus-substring-spec? s start end)
  549.       (error "Bad substring indices" 
  550.          sockfd flags family addr
  551.          s start end writer))
  552.  
  553.   (if (= start end) 0            ; Vacuous request.
  554.       (let loop ()
  555.     (receive (err nwritten) 
  556.          (writer sockfd flags s start end family addr)
  557.          (if err
  558.              (case err
  559.                ((errno/intr) (loop))
  560.                ((errno/again errno/wouldblock) 0)
  561.                (else (errno-error err sockfd flags family addr
  562.                       s start start end writer)))
  563.              nwritten)))))
  564.  
  565. (define-foreign send-substring/errno
  566.   (send_substring (integer sockfd)
  567.           (integer flags)
  568.           (string-desc buf)
  569.           (integer start)
  570.           (integer end)
  571.           (integer family)
  572.           (string-desc name))
  573.   (multi-rep (to-scheme integer errno_or_false)
  574.          integer))
  575.  
  576. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  577. ;;; getsockopt syscall 
  578. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  579.  
  580. (define (socket-option sock level option)
  581.   (cond ((not (socket? sock))
  582.      (error "socket-option: socket expected ~s" sock))
  583.     ((or (not (integer? level))(not (integer? option)))
  584.      (error "socket-option: integer expected ~s ~s" level option))
  585.     ((boolean-option? option)
  586.      (let ((result (%getsockopt (socket->fdes sock) level option)))
  587.        (cond ((= result -1) 
  588.           (error "socket-option ~s ~s ~s" sock level option))
  589.          (else (not (= result 0))))))
  590.     ((value-option? option)
  591.      (let ((result (%getsockopt (socket->fdes sock) level option)))
  592.        (cond ((= result -1) 
  593.           (error "socket-option ~s ~s ~s" sock level option))
  594.          (else result))))
  595.     ((linger-option? option)
  596.      (receive (result/on-off time)
  597.           (%getsockopt-linger (socket->fdes sock) level option)
  598.         (cond ((= result/on-off -1) 
  599.            (error "socket-option ~s ~s ~s" sock level option))
  600.           (else (if (= result/on-off 0) #f time)))))
  601.     ((timeout-option? option)
  602.      (receive (result/secs usecs)
  603.           (%getsockopt-linger (socket->fdes sock) level option)
  604.        (cond ((= result/secs -1) 
  605.           (error "socket-option ~s ~s ~s" sock level option))
  606.          (else (+ result/secs (/ usecs 1000))))))
  607.     (else
  608.      "socket-option: unknown option type ~s" option)))
  609.  
  610. (define-foreign %getsockopt/errno
  611.   (scheme_getsockopt (integer sockfd)
  612.              (integer level)
  613.              (integer optname))
  614.   (multi-rep (to-scheme integer errno_or_false)
  615.          integer))
  616.  
  617. (define-errno-syscall (%getsockopt sock level option) %getsockopt/errno 
  618.   value)
  619.  
  620. (define-foreign %getsockopt-linger/errno
  621.   (scheme_getsockopt_linger (integer sockfd)
  622.                 (integer level)
  623.                 (integer optname))
  624.   (multi-rep (to-scheme integer errno_or_false)
  625.          integer) ; error/on-off
  626.   integer) ; linger time
  627.  
  628. (define-errno-syscall 
  629.   (%getsockopt-linger sock level option) %getsockopt-linger/errno 
  630.   on-off
  631.   linger)
  632.  
  633. (define-foreign %getsockopt-timeout/errno
  634.   (scheme_getsockopt_timeout (integer sockfd)
  635.                  (integer level)
  636.                  (integer optname))
  637.   (multi-rep (to-scheme integer errno_or_false)
  638.          integer) ; error/secs
  639.   integer) ; usecs
  640.  
  641. (define-errno-syscall 
  642.   (%getsockopt-timeout sock level option) %getsockopt-timeout/errno
  643.   secs
  644.   usecs)
  645.  
  646. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  647. ;;; setsockopt syscall 
  648. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  649.  
  650. (define (set-socket-option sock level option value)
  651.   (cond ((not (socket? sock))
  652.      (error "set-socket-option: socket expected ~s" sock))
  653.     ((or (not (integer? level)) (not (integer? option)))
  654.      (error "set-socket-option: integer expected ~s ~s" level option))
  655.     ((boolean-option? option)
  656.      (%setsockopt (socket->fdes sock) level option (if value 1 0)))
  657.     ((value-option? option)
  658.      (%setsockopt (socket->fdes sock) level option value))
  659.     ((linger-option? option)
  660.      (%setsockopt-linger (socket->fdes sock) 
  661.                  level option 
  662.                  (if value 1 0) 
  663.                  (if value value 0)))
  664.     ((timeout-option? option)
  665.      (let ((secs (truncate value)))
  666.        (%setsockopt-timeout (socket->fdes sock) level option 
  667.                 secs
  668.                 (truncate (* (- value secs) 1000)))))
  669.     (else 
  670.      "set-socket-option: unknown option type")))
  671.  
  672. (define-foreign %setsockopt/errno
  673.   (scheme_setsockopt (integer sockfd)
  674.              (integer level)
  675.              (integer optname)
  676.              (integer optval))
  677.   (to-scheme integer errno_or_false))
  678.  
  679. (define-simple-errno-syscall 
  680.   (%setsockopt sock level option value) %setsockopt/errno)
  681.  
  682.  
  683. (define-foreign %setsockopt-linger/errno
  684.   (scheme_setsockopt_linger (integer sockfd)
  685.                 (integer level)
  686.                 (integer optname)
  687.                 (integer on-off)
  688.                 (integer time))
  689.   (to-scheme integer errno_or_false))
  690.  
  691. (define-simple-errno-syscall 
  692.   (%setsockopt-linger sock level option on-off time) %setsockopt-linger/errno)
  693.  
  694. (define-foreign %setsockopt-timeout/errno
  695.   (scheme_setsockopt_timeout (integer sockfd)
  696.                  (integer level)
  697.                  (integer optname)
  698.                  (integer secs)
  699.                  (integer usecs))
  700.   (to-scheme integer errno_or_false))
  701.  
  702. (define-simple-errno-syscall 
  703.   (%setsockopt-timeout sock level option secs usecs) %setsockopt-timeout/errno)
  704.  
  705. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  706. ;;; socket-option routines
  707. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  708.  
  709. (define (boolean-option? opt)
  710.   (member opt options/boolean))
  711.  
  712. (define (value-option? opt)
  713.   (member opt options/value))
  714.  
  715. (define (linger-option? opt)
  716.   (member opt options/linger))
  717.  
  718. (define (timeout-option? opt)
  719.   (member opt options/timeout))
  720.  
  721. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  722. ;;; host lookup
  723. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  724. (define-record host-info
  725.   name                    ; Host name
  726.   aliases                ; Alternative names
  727.   addresses                ; Host addresses
  728.  
  729.   ((disclose hi)            ; Make host-info records print like
  730.    (list "host" (host-info:name hi))))    ; #{host clark.lcs.mit.edu}.
  731.  
  732. (define (host-info arg)
  733.   (cond ((string? arg) (name->host-info arg))
  734.     ((socket-address? arg) (address->host-info arg))
  735.     (else (error "host-info: string or socket-address expected ~s" arg))))
  736.  
  737. (define (address->host-info name)
  738.   (if (or (not (socket-address? name)) 
  739.       (not (= (socket-address:family name) address-family/internet)))
  740.       (error "address->host-info: internet address expected ~s" name)
  741.       (receive (herrno name aliases addresses)
  742.           (%host-address->host-info/h-errno 
  743.            (socket-address:address name))
  744.      (if herrno
  745.          (error "address->host-info: non-zero herrno ~s ~s" name herrno)
  746.          (make-host-info name 
  747.                  (vector->list
  748.                   (C-string-vec->Scheme aliases   #f))
  749.                  (vector->list
  750.                   (C-string-vec->Scheme addresses #f)))))))
  751.  
  752. (define-foreign %host-address->host-info/h-errno
  753.   (scheme_host_address2host_info (string-desc name))
  754.   (to-scheme integer "False_on_zero")
  755.   static-string    ; host name
  756.   (C char**)    ; alias list
  757.   (C char**))   ; address list
  758.   
  759. (define (name->host-info name)
  760.   (if (not (string? name))
  761.       (error "name->host-info: string expected ~s" name)
  762.       (receive (herrno name aliases addresses)
  763.            (%host-name->host-info/h-errno name)
  764.      (if herrno
  765.          (error "name->host-info: non-zero herrno ~s ~s" herrno name)
  766.          (make-host-info name
  767.                  (vector->list
  768.                   (C-string-vec->Scheme aliases   #f))
  769.                  (vector->list
  770.                   (C-long-vec->Scheme   addresses #f)))))))
  771.  
  772. (define-foreign %host-name->host-info/h-errno
  773.   (scheme_host_name2host_info (string name))
  774.   (to-scheme integer "False_on_zero")
  775.   static-string    ; host name
  776.   (C char**)    ; alias list
  777.   (C char**))   ; address list
  778.   
  779.  
  780. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  781. ;;; network lookup
  782. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  783. (define-record network-info
  784.   name                    ; Network name
  785.   aliases                ; Alternative names
  786.   net)                    ; Network number
  787.  
  788. (define (network-info arg)
  789.   (cond ((string? arg) (name->network-info arg))
  790.     ((socket-address? arg) (address->network-info arg))
  791.     (else 
  792.      (error "network-info: string or socket-address expected ~s" arg))))
  793.  
  794. (define (address->network-info name)
  795.   (if (not (integer? name))
  796.       (error "address->network-info: integer expected ~s" name)
  797.       (let ((name (integer->string name))
  798.         (net (make-string 4)))
  799.     (receive (result name aliases)
  800.          (%net-address->network-info name net)
  801.       (make-network-info name 
  802.                  (vector->list
  803.                   (C-string-vec->Scheme aliases #f))
  804.                  (string->integer net))))))
  805.           
  806. (define-foreign %net-address->network-info
  807.   (scheme_net_address2net_info (string-desc name) (string-desc net))
  808.   (to-scheme integer "False_on_zero")
  809.   static-string    ; net name
  810.   (C char**))   ; alias list
  811.  
  812.   
  813. (define (name->network-info name)
  814.   (if (not (string? name))
  815.       (error "name->network-info: string expected ~s" name)
  816.       (let ((net (make-string 4)))
  817.     (receive (result name aliases)
  818.          (%net-name->network-info name net)
  819.        (make-network-info name
  820.                   (vector->list
  821.                    (C-string-vec->Scheme aliases #f))
  822.                   (string->integer net))))))
  823.           
  824. (define-foreign %net-name->network-info
  825.   (scheme_net_name2net_info (string name) (string-desc net))
  826.   (to-scheme integer "False_on_zero")
  827.   static-string     ; net name
  828.   (C char**))    ; alias list
  829.  
  830. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  831. ;;; service lookup
  832. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  833. (define-record service-info
  834.   name                    ; Service name
  835.   aliases                ; Alternative names
  836.   port                    ; Port number
  837.   protocol)                ; Protocol name
  838.  
  839. (define (service-info . args)
  840.   (cond ((string? (car args))  (apply name->service-info args))
  841.     ((integer? (car args)) (apply port->service-info args))
  842.     (else (error "service-info: string or integer expected ~s" args))))
  843.  
  844. (define (port->service-info name . maybe-proto)
  845.   (receive (proto)
  846.        (parse-optionals maybe-proto "")
  847.     (cond ((not (integer? name))
  848.        (error "port->service-info: integer expected ~s" name))
  849.       ((not (string? proto))
  850.        (error "port->service-info: string expected ~s" proto))
  851.       (else
  852.        (receive (result name aliases port protocol)
  853.             (%service-port->service-info name proto)
  854.             (make-service-info name 
  855.                        (vector->list
  856.                     (C-string-vec->Scheme aliases #f))
  857.                        port
  858.                        protocol))))))
  859.           
  860. (define-foreign %service-port->service-info
  861.   (scheme_serv_port2serv_info (integer name) (string  proto))
  862.   (to-scheme integer "False_on_zero")
  863.   static-string     ; service name
  864.   (C char**)     ; alias list
  865.   integer        ; port number
  866.   static-string) ; protocol name
  867.   
  868.   
  869. (define (name->service-info name . maybe-proto)
  870.   (receive (proto)
  871.        (parse-optionals maybe-proto "")
  872.     (if (or (not (string? name))
  873.         (not (string? name)))
  874.     (error "name->service-info: string expected ~s" name)
  875.     (receive (result name aliases port protocol)
  876.          (%service-name->service-info name proto)
  877.        (make-service-info name
  878.                   (vector->list
  879.                    (C-string-vec->Scheme aliases #f))
  880.                   port
  881.                   protocol)))))
  882.           
  883. (define-foreign %service-name->service-info
  884.   (scheme_serv_name2serv_info (string name) (string proto))
  885.   (to-scheme integer "False_on_zero")
  886.   static-string     ; service name
  887.   (C char**)     ; alias list
  888.   integer        ; port number
  889.   static-string) ; protocol name
  890.  
  891. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  892. ;;; protocol lookup
  893. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  894. (define-record protocol-info
  895.   name                    ; Protocol name
  896.   aliases                ; Alternative names
  897.   number)                ; Protocol number
  898.  
  899. (define (protocol-info arg)
  900.   (cond ((string? arg)  (name->protocol-info arg))
  901.     ((integer? arg) (number->protocol-info arg))
  902.     (else (error "protocol-info: string or integer expected ~s" arg))))
  903.  
  904. (define (number->protocol-info name) 
  905.   (if (not (integer? name))
  906.       (error "number->protocol-info: integer expected ~s" name)
  907.       (receive (result name aliases protocol)
  908.            (%protocol-port->protocol-info name)
  909.      (make-protocol-info name 
  910.                  (vector->list
  911.                   (C-string-vec->Scheme aliases #f))
  912.                  protocol))))
  913.  
  914. (define-foreign %protocol-port->protocol-info
  915.   (scheme_proto_num2proto_info (integer name))
  916.   (to-scheme integer "False_on_zero")
  917.   static-string    ; protocol name
  918.   (C char**)    ; alias list
  919.   integer)      ; protocol number
  920.   
  921. (define (name->protocol-info name)
  922.   (if (not (string? name))
  923.       (error "name->protocol-info: string expected ~s" name)
  924.       (receive (result name aliases protocol)
  925.            (%protocol-name->protocol-info name)
  926.      (make-protocol-info name
  927.                  (vector->list
  928.                   (C-string-vec->Scheme aliases #f))
  929.                  protocol))))
  930.           
  931. (define-foreign %protocol-name->protocol-info
  932.   (scheme_proto_name2proto_info (string name))
  933.   (to-scheme integer "False_on_zero")
  934.   static-string ; protocol name
  935.   (C char**)    ; alias list
  936.   integer)      ; protocol number
  937.  
  938. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  939. ;;; Lowlevel junk 
  940. ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
  941. ;; Used to pull address list back
  942. ;; based on C-string-vec->Scheme from cig/libcig.scm
  943. (define (C-long-vec->Scheme cvec veclen) ; No free.
  944.   (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
  945.     (mapv! (lambda (ignore) (make-string 4)) vec)
  946.     (%set-long-vector-carriers! vec cvec)
  947.     (mapv! string->integer vec)))
  948.  
  949. (define (integer->string num32)
  950.   (let* ((str   (make-string 4))
  951.      (num24 (arithmetic-shift num32 -8))
  952.      (num16 (arithmetic-shift num24 -8))
  953.      (num08 (arithmetic-shift num16 -8))
  954.      (byte0 (bitwise-and #b11111111 num08))
  955.      (byte1 (bitwise-and #b11111111 num16))
  956.      (byte2 (bitwise-and #b11111111 num24))
  957.      (byte3 (bitwise-and #b11111111 num32)))
  958.     (string-set! str 0 (ascii->char byte0))
  959.     (string-set! str 1 (ascii->char byte1))
  960.     (string-set! str 2 (ascii->char byte2))
  961.     (string-set! str 3 (ascii->char byte3))
  962.     str))
  963.  
  964. (define (string->integer str)
  965.   (+ (arithmetic-shift(char->ascii(string-ref str 0))24)
  966.      (arithmetic-shift(char->ascii(string-ref str 1))16)
  967.      (arithmetic-shift(char->ascii(string-ref str 2)) 8)
  968.      (char->ascii(string-ref str 3))))
  969.  
  970. ;; also from cig/libcig.scm
  971. (define-foreign %c-veclen-or-false
  972.   (veclen ((C "const long * ~a") c-vec)); redefining can we open cig-aux?
  973.   desc) ; integer or #f if arg is NULL.
  974.  
  975. ;; also from cig/libcig.scm
  976. (define-foreign %set-long-vector-carriers!
  977.   (set_longvec_carriers (vector-desc svec)
  978.             ((C "long const * const * ~a") cvec))
  979.   ignore)
  980.  
  981. ;; also from cig/libcig.scm
  982. (define (mapv! f v)
  983.   (let ((len (vector-length v)))
  984.     (do ((i 0 (+ i 1)))
  985.     ((= i len) v)
  986.       (vector-set! v i (f (vector-ref v i))))))
  987.